home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-03
/
qbfaqr01.zip
/
JUL.BAS
< prev
next >
Wrap
BASIC Source File
|
1992-08-12
|
10KB
|
304 lines
' From: JOE NEGRON on Un'iNet QBASIC echo
DEFINT A-Z
DECLARE FUNCTION Date2Day% (DateX$)
DECLARE FUNCTION Date2Eng$ (DateX$)
DECLARE FUNCTION Date2Mth% (DateX$)
DECLARE FUNCTION Date2Serial& (DateX$)
DECLARE FUNCTION Date2Year% (DateX$)
DECLARE FUNCTION DayOfTheCentury& (DateX$)
DECLARE FUNCTION DayOfTheWeek$ (DateX$)
DECLARE FUNCTION DayOfTheYear% (DateX$)
DECLARE FUNCTION DaysBetweenDates& (Date1$, Date2$)
DECLARE FUNCTION Julian% (DateX$)
DECLARE FUNCTION Serial2Date$ (Serial&)
DECLARE FUNCTION LeapYear% (Year%)
DECLARE FUNCTION MDY2Date$ (Month%, Day%, Year%)
DECLARE FUNCTION MthName$ (DateX$)
DECLARE FUNCTION ValidDate% (DateX$)
DECLARE FUNCTION WeekDay$ ()
'External routine(s)
DECLARE SUB Interrupt (IntNum%, InRegs AS RegType, OutRegs AS RegType)
'***********************************************************************
'* FUNCTION Date2Day%
'*
'* PURPOSE
'* Returns the day number given a date in the standard date format.
'***********************************************************************
FUNCTION Date2Day% (DateX$) STATIC
Date2Day% = VAL(MID$(DateX$, 4))
END FUNCTION
'***********************************************************************
'* FUNCTION Date2Eng$
'*
'* PURPOSE
'* Returns a string variable representing the English form of the
'* date given a date in the standard date format.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Day% (DateX$)
'* FUNCTION Date2Year% (DateX$)
'* FUNCTION MthName$ (DateX$)
'***********************************************************************
FUNCTION Date2Eng$ (DateX$) STATIC
Date2Eng$ = MID$(STR$(Date2Day%(DateX$)), 2) + " "_
+ MthName$(DateX$) + " "_
+ RIGHT$(STR$(Date2Year%(DateX$)), 2)
END FUNCTION
'***********************************************************************
'* FUNCTION Date2Mth%
'*
'* PURPOSE
'* Returns the month number given a date in the standard date format.
'***********************************************************************
FUNCTION Date2Mth% (DateX$) STATIC
Date2Mth% = VAL(DateX$)
END FUNCTION
'***********************************************************************
'* FUNCTION Date2Serial&
'*
'* PURPOSE
'* Returns the astronomical Julian day number given a date in the
'* standard date format. Note that the year must be 1583 or greater.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Day% (DateX$)
'* FUNCTION Date2Mth% (DateX$)
'* FUNCTION Date2Year% (DateX$)
'***********************************************************************
FUNCTION Date2Serial& (DateX$) STATIC
Month% = Date2Mth%(DateX$)
Day% = Date2Day%(DateX$)
Year% = Date2Year%(DateX$)
IF Month% > 2 THEN
Month% = Month% - 3
ELSE
Month% = Month% + 9
Year% = Year% - 1
END IF
TA& = 146097 * (Year% \ 100) \ 4
TB& = 1461& * (Year% MOD 100) \ 4
TC& = (153 * Month% + 2) \ 5 + Day% + 1721119
Date2Serial& = TA& + TB& + TC&
END FUNCTION
'***********************************************************************
'* FUNCTION Date2Year%
'*
'* PURPOSE
'* Returns the year number given a date in the standard date format.
'***********************************************************************
FUNCTION Date2Year% (DateX$) STATIC
Date2Year% = VAL(MID$(DateX$, 7))
END FUNCTION
'***********************************************************************
'* FUNCTION DayOfTheCentury&
'*
'* PURPOSE
'* Returns the number of the day of the century given a date in the
'* standard date format.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Year% (DateX$)
'* FUNCTION DaysBetweenDates& (Date1$, Date2$)
'* FUNCTION MDY2Date$ (Month%, Day%, Year%)
'***********************************************************************
FUNCTION DayOfTheCentury& (DateX$) STATIC
Year% = Date2Year%(DateX$)
DayOfTheCentury& = DaysBetweenDates&(MDY2Date$(12, 31, Year%_
- (Year% MOD 100) - 1), DateX$)
END FUNCTION
'***********************************************************************
'* FUNCTION DayOfTheWeek$
'*
'* PURPOSE
'* Returns a string stating the day of the week given a date in the
'* standard date format.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Serial& (DateX$)
'***********************************************************************
FUNCTION DayOfTheWeek$ (DateX$) STATIC
DayOfTheWeek$ = MID$("MonTueWedThuFriSatSun",_
((Date2Serial&(DateX$) MOD 7) + 1) * 3 - 2, 3)
END FUNCTION
'***********************************************************************
'* FUNCTION DayOfTheYear%
'*
'* PURPOSE
'* Returns the number of the day of the year (1-366) given a date in
'* the standard date format.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Year% (DateX$)
'* FUNCTION DaysBetweenDates& (Date1$, Date2$)
'* FUNCTION MDY2Date$ (Month%, Day%, Year%)
'***********************************************************************
FUNCTION DayOfTheYear% (DateX$) STATIC
DayOfTheYear% = DaysBetweenDates&(MDY2Date$(12, 31,_
Date2Year%(DateX$) - 1), DateX$)
END FUNCTION
'***********************************************************************
'* FUNCTION DaysBetweenDates&
'*
'* PURPOSE
'* Returns the number of days between any two dates. These two dates
'* are to be given in the standard date format.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Serial& (DateX$)
'***********************************************************************
FUNCTION DaysBetweenDates& (Date1$, Date2$) STATIC
DaysBetweenDates& = ABS(Date2Serial&(Date1$) - Date2Serial&(Date2$))
END FUNCTION
'***********************************************************************
'* FUNCTION Julian%
'*
'* PURPOSE
'* Returns an integer value representing the Julian day of the year.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Day% (DateX$)
'* FUNCTION Date2Mth% (DateX$)
'* FUNCTION Date2Year% (DateX$)
'* FUNCTION LeapYear% (Year%)
'***********************************************************************
FUNCTION Julian% (DateX$) STATIC
FullMonths% = Date2Mth%(DateX$) - 1
JulTmp% = 0
FOR X% = 1 TO FullMonths% 'accumulate the number of
SELECT CASE X% ' days for full months
CASE 1, 3, 5, 7, 8, 10
JulTmp% = JulTmp% + 31
CASE 4, 6, 9, 11
JulTmp% = JulTmp% + 30
CASE 2
JulTmp% = JulTmp% + 28 - LeapYear%(Date2Year%(DateX$))
END SELECT
NEXT X%
JulTmp% = JulTmp% + Date2Day%(DateX$) 'add days in present month
Julian% = JulTmp%
END FUNCTION
'***********************************************************************
'* FUNCTION LeapYear%
'*
'* PURPOSE
'* Determines whether or not the given year is a leap year.
'***********************************************************************
FUNCTION LeapYear% (Year%) STATIC
'If the year is evenly divisible by 4 but not evenly divisible
'by 100, or if the year is evenly divisible by 400, then it is
'a leap year.
LeapYear% = (Year% MOD 4 = 0 AND Year% MOD 100 <> 0) OR_
(Year% MOD 400 = 0)
END FUNCTION
'***********************************************************************
'* FUNCTION MDY2Date$
'*
'* PURPOSE
'* Converts Month%, Day%, and Year% to a string in the standard date
'* format.
'***********************************************************************
FUNCTION MDY2Date$ (Month%, Day%, Year%) STATIC
MDY2Date$ = RIGHT$("0" + MID$(STR$(Month%), 2), 2) + "-"_
+ RIGHT$("0" + MID$(STR$(Day%), 2), 2) + "-"_
+ RIGHT$("000" + MID$(STR$(Year%), 2), 4)
END FUNCTION
'***********************************************************************
'* FUNCTION MthName$
'*
'* PURPOSE
'* Returns then name of the month given a string in the standard date
'* format.
'***********************************************************************
FUNCTION MthName$ (DateX$) STATIC
MthName$ = MID$("JanFebMarAprMayJunJulAugSepOctNovDec", VAL(DateX$)_
* 3 - 2, 3)
END FUNCTION
'***********************************************************************
'* FUNCTION Serial2Date$
'*
'* PURPOSE
'* Returns a date in the standard date format given a Julian day
'* number.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION MDY2Date$ (Month%, Day%, Year%)
'***********************************************************************
FUNCTION Serial2Date$ (Serial&) STATIC
X& = 4 * Serial& - 6884477
Y& = (X& \ 146097) * 100
D& = (X& MOD 146097) \ 4
X& = 4 * D& + 3
Y& = (X& \ 1461) + Y&
D& = (X& MOD 1461) \ 4 + 1
X& = 5 * D& - 3
M& = X& \ 153 + 1
D& = (X& MOD 153) \ 5 + 1
IF M& < 11 THEN
Month% = M& + 2
ELSE
Month% = M& - 10
END IF
Day% = D&
Year% = Y& + M& \ 11
DateX$ = MDY2Date$(Month%, Day%, Year%)
Serial2Date$ = DateX$
END FUNCTION
'***********************************************************************
'* FUNCTION ValidDate%
'*
'* PURPOSE
'* Returns TRUE if the given date represents a real date or FALSE if
'* the date is in error.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION Date2Serial& (DateX$)
'* FUNCTION Serial2Date$ (Serial&)
'***********************************************************************
FUNCTION ValidDate% (DateX$) STATIC
ValidDate% = DateX$ = Serial2Date$(Date2Serial&(DateX$))
END FUNCTION
'***********************************************************************
'* FUNCTION WeekDay$
'*
'* PURPOSE
'* Uses DOS ISR 21H, Function 2AH (Get Date) to return the current
'* day of the week.
'*
'* EXTERNAL ROUTINE(S)
'* QBX.LIB
'* -------
'* SUB Interrupt (IntNum%, InRegs AS RegType, OutRegs AS RegType)
'***********************************************************************
FUNCTION WeekDay$ STATIC
InRegs.ax = &H2A00
Interrupt &H21, InRegs, OutRegs
al% = OutRegs.ax AND &HFF 'extract al register
WeekDay$ = MID$("SunMonTueWedThuFriSat", (al% + 1) * 3 - 2, 3)
END FUNCTION